home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac100% 1998 November
/
MAC100-1998-11.ISO.7z
/
MAC100-1998-11.ISO
/
オンラインソフト定点観測
/
ユーティリティ
/
Mops 3.2.sea
/
Mops 3.2
/
Mops ƒ
/
zClass
< prev
next >
Wrap
Text File
|
1998-06-19
|
63KB
|
2,471 lines
(* file zClass
This file is part of the PPC version of the high-level class/object
implementation. It's a "z" file - it's not target compiled, but is
loaded on the PPC itself. Some of the PPC code is target compiled in
qpClass, since we need it while we're still target compiling. I would
have liked to get ALL the class implementation into qpClass, but this
proved to bristle with far too many problems, so here we include
everything that didn't make it, which is quite a lot.
*)
¥ Here are all our various class/object formats:
(* ================= Object header ======================
Note if the obj is an ivar, it doesn't have a header if it's in a record,
unless the ivar is indexed. Indexed ivars always have headers, no matter
what, since the indexing code relies on it.
PPC notes: we have to make some minor changes to the object header format
for various reasons.
1. As objects live in the data area, we need a back pointer to the dic
entry in the code area, so methods like .ID: work.
2. The class pointer is a 4-byte relocatable address, and we want it to
be aligned.
3. The indexed length of the object now always occupies the 4 bytes at
the end of the indexed descriptor, whereas on the 68k, although we
allocated 4 bytes, we normally only took notice of the low 2 bytes.
We want the 4 bytes preceding the obj's data to look like a negative
indexed length if the object isn't indexed.
So we end up with this layout:
4 bytes Back pointer to cfa of obj's dic entry (relocatable).
Zero if no dic entry, or if no name field there.
4 bytes Class pointer (relocatable).
2 bytes Self relative offset to the class pointer.
For simple objects (i.e. not embedded), this is -4.
For embedded objects, it will be more negative. Note it
will always be negative.
2 bytes Self relative offset to the indexed area. If not indexed,
this will be 2, pointing to the next byte which is the first
data byte of the object. This means, if we erroneously try
to access the indexed area of a non-indexed object, we'll
get sent to the non-indexed data area, and try to interpret
the preceding 4 bytes as an "indexed length" (which is what
precedes a valid indexed area). But these 4 bytes are these
two offsets, which will always appear as a negative number.
If we're doing range checking, this will always trap.
We did a similar sneaky trick on the 68k, but the field
lengths/positions were different.
(object's data starts here)
This format means that when multiply inheriting, we need 4 bytes
separating each group of ivars ("embedded object"), not 2 as on
the 68k.
For indexed objects, the indexed area (after the ivars) is preceded by
the indexed descriptor (xdesc) with the following format. This format
is the same as on the 68k, except that it starts off-aligned, i.e.
the #elements field is 4-byte aligned.
2 bytes Width of indexed elements (in bytes)
4 bytes Number of elements minus 1 (i.e. LIMIT-1).
We can check this with a trap instruction.
============== Class dictionary entry ================
link/name/hndlr as for normal words - normal class hndlr is $BC1D,
and for imported classes, $BC2D.
Note that the offsets are defined in 2 places, which must agree! -
here, and in pNuc4.
2 bytes flags
(note - we're now aligned)
(offs 2) 32 bytes links to 8-way hashed method chains (relative)
(offs 34) 4 bytes link to ivar chain (relative)
(offs 38) 2 bytes padding for alignment of the n-way, and to put
the next fields in the same place as on the 68k,
which simplifies (findM).
(offs 40) 2 bytes non-indexed data length
(offs 42) 2 bytes width of indexed elements, or zero if not indexed
(offs 44) 2 bytes "xdispl offs" - the ivar offset where indexing starts
(used by large_obj_arrays), or zero if none.
(offs 46) 4(n+1) bytes
n-way to superclasses (n relocatable addrs terminated by zero)
Flag bits:
$0001 "large" - indexed with > 64K elements.
$0002 class is exported from a module
$8000 class is META (we use this to terminate NW_IVsetup)
Note: on the 68k, at the class cfa there was a call to BLD, the word
which built an object. These 4 bytes also served as a unique marker
identifying a class dic entry, since we did a JSR to BLD, and this
always had the same bit pattern. We treated the class handler code
the same as for a colon definition, and simply BSR'd to the cfa.
On the PPC we'll really use class_h, so that a class won't
look like a colon definition any more. This is a bit more logical
and shouldn't cause any problems. In any case, we couldn't use a
call to BLD as a unique marker, since calls are all self-relative
on the PPC so that calls to any particular word will have a different
bit pattern depending on where they are.
class_h is $BC1D, and will give an error if we try to EXECUTE a class
(as with all $BCxx codes). I doubt this will break any existing code.
Note also we've moved the "flags" from after the indexed width item,
up to be the first item. This is so the 4-byte items come out aligned
without sundry padding.
============== ivar dictionary entry ================
¥ note: this format is the same on the PPC and 68k, for once!
4 bytes hashed name
4 bytes link to prev ivar dic entry (self-relative addr)
4 bytes class pointer (relocatable)
2 bytes offset of this ivar's data from the base addr of the class
2 bytes number of elements if indexed, or zero if not
2 bytes flags
Flag bits: (zero is rightmost - what will we do on PowerPC?)
$0001 ivar gets an object header
$0002 this is a static ivar
$0004 this is a public ivar
Note: although indexed objects can have 2^^32 elements, we are
assuming that an ivar can't have more than 64K elements. This is
because we are limiting the maximum ivar length of a class to 64K bytes,
which is a stricter condition. Would anybody want a longer ivar than
this??
============== Method dictionary entry ================
4 bytes hashed name
4 bytes link to prev method dic entry (self-relative addr)
2 bytes method flags
2 bytes 0 (alignment)
2 bytes $BE40 - "handler code" - not actually used as a handler, but
marks this as a method for decompiler etc. Note that an
inline method uses the code BD40, so I can just look for
40 in the low byte to see if it's a method.
2 bytes flag bytes as for colon defns, giving number of named parms etc.
This is the method's cfa (xt) here.
(method code follows)
Method flag bits:
$0001 private method (note other way round to ivars - we're using
1 for the unusual case)
$0080 there's a callFirst and/or callLast method
Note that the method code starts 6 bytes later than in the 68k version.
==========================================================
*)
34 constant IFA_offset
: ]C true -> cstate ; immediate
: C[ false -> cstate ; immediate
¥ these are defined in qpClass:
¥ 0 value PUB/PRIV ¥ -1 private, 1 public, 0 default - for ivars and methods
¥ false value STATIC? ¥ true if following ivars are to be static
¥ 0 value ^COMP_CLASS ¥ addr of the class we're currently compiling
¥ 0 value PIVAR ¥ hashed name of any public ivar we're accessing
¥ 0 value PIVSEL ¥ hashed selector of any msg being sent to
¥ to a public ivar
¥ 0 value NEWOBJECT ¥ addr of object being created
¥ 0 value #SUP ¥ number of superclasses for current class
¥ 0 value SUPERS_TO_SKIP
¥ 0 value INITID
0 value thisM
0 value superM
0 value tempObjs ¥ gets addr of class Dummy which we use for temp objects
¥ ===============================
¥ UTILITY WORDS
¥ ===============================
: PRIVATE -1 -> pub/priv ; ¥ following methods and ivars will be private
: PUBLIC 1 -> pub/priv ; ¥ following methods and ivars will be public
: END_PRIVATE 0 -> pub/priv ; ¥ back to the default
: END_PUBLIC 0 -> pub/priv ; ¥ ditto
¥ TOfind looks for a temp (local) object.
: TOfind { str-addr -- ^ivar offs T | -- str-addr F }
str-addr
tempObj_framesize NIF false EXIT THEN ¥ out if no temp objects
hash
tempObjs <findIV>
IF ¥ ( -- ^ivar offs xdispl-offs )
drop ¥ xdispl-offs must be zero for class Dummy
dup $ FFFE >=
IF ¥ self or super - mustn't match these in class Dummy!
2drop str-addr false EXIT
THEN
true
ELSE str-addr false
THEN
;
(*
LocFind will be called from Ufind, which is the vector that gets first
shot at recognizing a word.
It looks at all the possibilities involving local names, which are
not in the regular dictionary. These possibilities are: named parms/locals,
local objects, and if a class is being compiled, ivars of this class.
In the latter case, we arrange for the ivar's address to
be pushed at run time simply by compiling ^base followed by an add of the
ivar's offset - our code generation will produce optimal code for this.
We then have to return the xt of some word to keep FIND happy - we don't
need to compile anything else, so we use the xt of NULL and return a 1
instead of True - this makes FIND think it's immediate. So NULL is
executed immediately, which does precisely nothing.
The one exception to this is if the "ivar" turns out to be SELF or SUPER
- in this case we need to call the nucleus word SELF which works out
the right base address (this is what happened pre-2.5). Here we keep
FIND happy by pushing the xt of SELF and True, so that it sees we've
found SELF.
*)
: LocFind ¥ ( str-addr -- cfa T | -- str-addr F )
Pfind ?dup ?EXIT ¥ Found a named parm/local
TOfind
IF ¥ Found temp obj
nip ¥ Don't need its dic addr
postpone locReg postpone literal postpone +
['] null 1 EXIT
THEN
¥ Now we look for an ivar name
cstate NIF false EXIT THEN ¥ search fails if we're not compiling
¥ a class
dup hash ^comp_class IFA_offset false (findM)
IF ¥ Found ivar
nip nip ¥ don't need embedded obj offs or
¥ string addr
12 + w@ ¥ ivar offset
dup $ FFFE >= ¥ is it SELF or SUPER (just used in
¥ isolation)?
IF drop
" (^base) 4- dup w@x + 8 +" evaluate ¥ i.e. SELF - but I can't evaluate
¥ that, or we'll end up here again
¥ and infinitely recurse!
ELSE
postpone (^base) postpone literal postpone +
THEN
['] null 1
ELSE false
THEN ;
¥ 0 -> quitvec 0 -> abortvec 0 -> objInit ¥ clear vectors
¥ ' pfind -> ufind
¥ in qpClass
¥ : ?CLASS ¥ Error if not compiling a class definition.
¥ cstate 0= ?error 115 ;
¥ ========================
¥ BINDING
¥ ========================
0 value OBJ_BASE
0 value OBJ_DISPL
0 value OBJ_LOCAL_DISPL
0 value OBJ_IND
false value SELF?
(* Note: I think our obj_ind value might become obsolete on the PPC, since
we don't now use an indirect count in an OD, but just do repeated fetches
to different registers till we come to the data we want.
On the 68k, as far as I can tell, the only time obj_ind wasn't zero was
when we did an early bind to an addr on the stack, or to an objPtr (which
used the same code). This was also the reason we kept two offsets
- obj_displ and obj_local_displ. Obj_displ applied before any indirection
steps, and obj_local_displ after. I think on the PPC these complexities
might be able to go away.
*)
: (OBJ) ¥ Called from within an inline method. Passes the object's
¥ base and displacement to Handlers to generate the correct
¥ address. Optimization will then apply.
obj_base obj_displ
obj_ind genaddr
obj_local_displ postpone literal postpone + ;
: (IX)
(* Called from within an inline method. Compiles code to generate
the indexed address.
^comp_class has been set by inl_bind to the class of the obj
we're binding to. One tricky point is that to access the indexed
area, we have to use the dlen value in this class, not the class
of the method we're calling (which may be a superclass). But
the obj_local_displ has already had the embedded object offset
added in (if any). We have to ignore this, since we're using
the object's class, not the method's. When the method was found,
the value emb_obj_offs was set to this offset, so we subtract
it here.
*)
^comp_class dlen&xwid swap
self?
IF drop -1 ELSE #off-align 6 + THEN
obj_base obj_displ obj_local_displ
emb_obj_offs -
obj_ind ^comp_class ffa w@
genxaddr ;
: ^BASE
compinline?
IF (obj)
ELSE postpone (^base)
THEN ; immediate
: ^ELEM
compinline?
IF (ix)
ELSE " (^elem)" evaluate ¥ need PPC version
THEN ; immediate
: OBJ postpone ^base ; immediate ¥ for backward compatibility
: IX postpone ^elem ; immediate ¥ ditto
forward enter_meth_in_mod
local EARLY_BIND { oCfa oBase oDispl oLDispl oind slf? ¥ ^mod ptr -- }
: INL_BIND ¥ ( -- b )
^comp_class cstate self? ¥ Save over upcoming evaluate
slf? NIF objClass -> ^comp_class THEN ¥ Set ^comp_class and cstate
true -> cstate ¥ so ivars are accessible
slf? -> self?
oCfa inline_h
-> self? -> cstate -> ^comp_class ¥ Restore
;
: MODULE_BIND
heldMod dup
@ @ ¥ get mod handle and dereference - addr of mod start
-> ^mod
^mod 8 + -> ptr ¥ self-rel addr of exports table
ptr @ ++> ptr ¥ ptr -> start of table
0 -> methIndex
BEGIN
ptr @ dup 0<
IF ¥ we have a problem - we didn't find the entry in the
¥ module's export table, though it ought to be there!
¥ Maybe heldMod should have been zero, and we shouldn't
¥ have been trying to do a module bind at all??
cr cr ." heldMod " heldMod .h cr cr
heldMod 32 - 64 dump
198 die ¥ "internal error"
THEN
^mod + oCfa =
NWHILE
4 ++> methIndex 4 ++> ptr
REPEAT
¥ methIndex now has the export table offset for the method.
(obj) ¥ compile push of obj addr (clears heldMod!)
( heldMod ) lit_addr ¥ and a push of the module's addr
methIndex postpone literal ¥ and a push of export table offset
['] enter_meth_in_mod call_h
;
: NORM_BIND
heldMod
IF module_bind
ELSE oCfa (obj) call_h ¥ call_h will see by the handler code
THEN ¥ that this is a method, and do the
; ¥ right things, hopefully
:loc EARLY_BIND ¥ { oCfa oBase oDispl oLDispl oind slf? -- }
obj_base obj_displ obj_local_displ obj_ind ¥ Save
oBase -> obj_base oDispl -> obj_displ
OLdispl -> obj_local_displ oind -> obj_ind
oCfa 2- w@ $ BD40 =
IF inl_bind
ELSE norm_bind
THEN
-> obj_ind -> obj_local_displ
-> obj_displ -> obj_base ¥ Restore
;loc
: BIND_TO_OBJ { cfa ^obj offs -- }
cfa
-1 ¥ -1 as "base" signals handlers to generate
^obj ¥ a normal dic addr. We still carry the
¥ offs here since if we need to access the
¥ indexed area, we want the original obj addr,
¥ not some embedded object.
offs 0 false early_bind ;
: BIND_TO_STK { xt ¥ svHeldMod -- }
heldMod -> svHeldMod 0 -> heldMod
xt hStkObj ¥ ( -- xt base displ )
svHeldMod -> heldMod
0 0 false early_bind ;
: BIND_TO_IVAR { cfa offs -- }
cfa obj_base obj_displ
obj_local_displ offs +
obj_ind false early_bind ;
: BIND_TO_TMPOBJ { cfa offs -- }
cfa
<'> locReg 3+ c@ ¥ current locReg number
offs
0 0 false early_bind ;
: BIND_TO_SELF { cfa offs -- }
cfa obj_base obj_displ offs obj_ind true early_bind ;
¥ ============================
¥ :CLASS etc.
¥ ============================
(*
Here we set up some quantities so that we can send messages to SELF
or SUPER. These are treated syntactically as ivars, so to implement
them we actually set up dummy ivars SELF and SUPER.
When we're processing a :CLASS definition, we plug the appropriate
addresses into these ivars. ^SELF is a word defined to return the
addr of the dummy ivar SELF, so we can do the plugging.
In the case of SUPER, there may be several superclasses, so we have
to go through a class descriptor, since that's the only place we look
for an n-way (a set of addresses). So we set the "class" of SUPER
to a dummy class SUPCL, which has no ivars or methods (so the search
will pass right on by), and plug the superclass pointer of SUPCL to
point to the current n-way for the superclasses of the class we're
defining.
*)
¥ : ^SELF self_vbl displace ;
: :CLASS
?exec header $ BC1D codeW,
CDP -> ^comp_class
0 -> pub/priv 0 -> #1st 0 -> #last
false -> rec? false -> union? false -> static?
307
; immediate
: MERGE_INFO { ^sup ivlen ¥ ^wid wid prevWid -- dlen }
^sup dlen&xwid -> wid ¥ indexed width of this superclass
^sup ffa 1+ c@ 5 and ¥ Merge "general" and "indexed" flags with
^comp_class ffa 1+ cset ¥ what we have already
wid 0EXIT ¥ If this superclass not indexed, we're done
¥ This class is indexed - we need to check if prev classes were indexed
¥ and make sure the widths are compatible.
^comp_class dfa 2+ -> ^wid ¥ Addr of wid field in class we're building
^wid w@ -> prevWid ¥ Get previous width
wid 32760 u> ¥ "indexed width" of 32766/7 really means
IF ¥ obj_array.
prevWid ¥ In this case if we already have a width,
IF prevWid -> wid ¥ we use that,
ELSE wid
ivlen -> wid ¥ otherwise current ivar len becomes the width.
( old wid ) 32766 =
IF ¥ large_obj_array - mark boundary between ivars
¥ we are/aren't mapping to the indexed area
ivlen aligned ^comp_class xoffa w!
wid aligned 4+ -> wid ¥ and allow for ^class offset
¥ and indexed area offset
¥ before each element
THEN
THEN
THEN
prevWid
NIF wid ^wid w! ¥ If no prev width, set width & we're done
ELSE prevWid wid <> ?error 88 ¥ "Incompatible indexed widths"
THEN
;
local (SUP) { ¥ ^supcl ivlen ^nway ^sup ^newClass thisLen -- }
: NEXT_SUPER ( cfa -- )
chkClass -> ^sup
^sup relocCode, ¥ Add ^class to n-way
^sup ivlen merge_info -> thisLen
#sup IF ¥ If this is a subsequent class,
ivlen #align4 4+ -> ivlen ¥ align and allow for ^class offset and
¥ 2 extra bytes padding
THEN
thisLen ++> ivlen ¥ And add ivar length of new class
1 ++> #sup ;
: SUPERS_LOOP
BEGIN ¥ Loop over superclasses:
' ¥ cfa of next item on list
}or)? IF drop EXIT THEN
( cfa ) next_super ¥ handle next superclass
¥ 1super? ?EXIT ¥ Yerk has only one superclass
AGAIN ;
:loc (SUP)
307 ?pairs ¥ Make sure we're in the right place
CDP -> ^newClass
46 ( classSize ) code_reserve ¥ Space for class record
CDP -> ^nway ¥ n-way for superclasses will
0 -> ivlen 0 -> #sup ¥ start here
^newClass 2+ 32 bounds
DO ^nway i displ! 4 +LOOP ¥ point methods links to nway
^nway ^newClass IFA displ! ¥ and ivars link
false -> relocChk?
supers_loop ¥ Loop over superclasses
0 code, ¥ Terminate n-way
" SUPCL" sFind drop -> ^supcl
^supcl 2+ 32 bounds
DO ^nway i displ! 4 +LOOP ¥ we point the method and ivar links
^nway ¥ in supcl to the n-way
^supcl IFA displ!
^comp_class xoffa w@
" SUPCL" sFind drop xoffa w! ¥ and set xoffs in supCl
ivlen ^comp_class dfa w! ¥ Set total ivar length
¥ ^comp_class ^self 8 + reloc! ¥ Store ^class in SELF
true -> relocChk?
postpone ]c ¥ In a class definition
308
;loc
: SUPER{ ( false -> 1super? ) (sup) ; immediate
¥ : SUPER( postpone super{ ; immediate
¥ : <SUPER true -> 1super? (sup) ; immediate
¥ For compatibility with Yerk -- only looks for 1 superclass
: (;CL)
postpone [ postpone c[
;
: ;CLASS
(;cl) 308 ?defn ; immediate
1 value DFRSELID ¥ 1 means no late bind going on - otherwise it's
¥ the selector we're late binding with
true value SLCTRS? ¥ Set false to treat selectors as normal words
¥ for full ANSI compatibility
: SEL? ¥ ( addr -- addr b ) True if word at addr is a selector xxx:
slctrs? NIF false EXIT THEN
dup count tuck 1- + c@ & : =
swap 1 > and ;
: GETSELECT ¥ Gets a selector from the input stream
mword
sel? not ?error 124
hash
1 -> dfrSelID ;
' null vect GET1ST&LAST
' null vect DoCall1ST
' null vect DoCallLast
: M_HEADER { selID -- } ¥ Builds a method header and entry sequence.
¥ Note: also called from the assembler.
selID ^comp_class MFA selID hashed-hdr ¥ Build header
drop ¥ drop extra selID (needed by MFA)
CDP 4- -> ^meth_link
pub/priv -1 = 1 and codeW, ¥ public/private flag (default is public)
0 codeW, ¥ padding for alignment
$ BE400000 code, ¥ "handler code" for PPC methods,
¥ and initial flag bytes
CDP 2- -> thisM ¥ Remember method cfa
;
¥ 0 codeW, ¥ space for parm flags (or do it in Mentry?)
¥ Mentry ; ¥ Compile the entry sequence
: :M { ¥ selID -- } ¥ Starts compiling a method.
CDP -> last_colon_defn ¥ used by compile_call in checking where
¥ a call is coming from
true -> method?
?class
rec? ?error 191 ¥ unmatched '{' in ivar list
0 -> superM
getSelect -> selID
10 -> cstate ¥ Means we've read :m, no call_1st yet
selID ^comp_class MFA_offset true (findm) ¥ is method already defined?
IF
-> superM
¥ warnings?
¥ IF cr CDP count type type# 182 ¥ "Method redefined"
¥ THEN
heldMod
NIF superM ^comp_class > ?error 183 THEN
¥ - but if in same class, error
drop
THEN
get1st&last ¥ ?unHoldMod
CDP -> const_data_start
selID m_header ¥ Build method header
#1st #last +
IF $ 80 thisM 5 - cset THEN ¥ set call1st/callLast flag
obj_base_reg -> obj_base ¥ gpr20
0 -> obj_displ ¥ For any inline method calls
false ppc_entry ¥ Start to compile the method
drop 305 ¥ change security marker to say method
doCall1st ¥ Compile any Call1st calls first
; immediate
: ;M
true -> method? ¥ things might have happened during the defn
¥ to make it false, like compilation being
¥ turned off and on. This doesn't matter,
¥ but we definitely need it true here.
#last IF doCallLast THEN
curr-def 2- (;)
0 -> #1st 0 -> #last
305 ?defn ; immediate
¥ ============== Local sections for methods ==============
¥ These function just like regular local sections. The implementation
¥ is nearly the same.
0 value mloc_addr
: MLOCAL ¥ Starts a local section for methods
local? ?error 93 1 -> local? ¥ We change it to the normal -1
¥ as soon as "{" is read.
CDP -> CD_gpr_loc
postpone :m drop
postpone [
CDP -> mloc_addr
$ 48000000 code, ¥ uncond branch to be resolved by :mloc
private
;
: :MLOC
public ?loc getSelect drop
CDP -> const_data_start
$ BE030000 code, ¥ marks this as the :mloc position
¥ (just for disassembly)
true -> method?
false -> local? ¥ so entry sequence gets compiled
true -> mloc? ¥ so const data gets handled properly
false ppc_entry ¥ handle ppc proc entry
drop 309 ¥ security marker for :mloc
curr-def
mloc_addr -> curr-def
PLentry
-> curr-def
tempObj_framesize IF initTemps THEN
; immediate
: ;MLOC
309 ?defn
false -> leaf? ¥ let's just reduce the bug possibilities!
#last IF doCallLast THEN
mloc_addr 2- (;)
¥ #last IF true -> method? doCallLast ( defnEnd) false -> method? THEN
0 -> #1st 0 -> #last
curr-def mloc_addr - ¥ finally we resolve the forward branch
mloc_addr +! ¥ from MLOCAL
; immediate
¥ ================ INDEXED, GENERAL etc. =================
¥ These are words which can appear in a class declaration, in the
¥ position
¥ :class someClass super{ someSuper } general
¥ They add attributes to the class.
: INDEXED ¥ ( width -- ) Sets a class and its subclasses to indexed
?class ^comp_class dfa 2+ w! ;
: LARGE ; ¥ in effect, this always applies on the PPC
: GENERAL
(* Sets the "general" option on a class, which will force an ivar of that class
to be a general object with a class pointer (so it can be late-bound to) even
if it's within a record. Normally you should just not put such ivars in a
record, but using GENERAL gives a bit of extra security, for classes for which
you know that they will definitely be late-bound to. (An attempt to late-bind
to an ivar without a class pointer will give the "not an object" error at run
time, which isn't easy to track down.)
Note that indexed classes are always general anyway. Also if there's a message
sent to [self] somewhere in one of the methods, we know that the class *must*
be general, so in this case we simply set the general attribute.
*)
?class ^comp_class ffa 1+ dup c@ 4 or swap c! ;
¥ ===========================
¥ SELECTORS
¥ ===========================
¥ First, here are the special-purpose things which can follow a selector.
¥ These can't appear in isolation.
¥ We allow ** and [] as synonyms of [ ] to late-bind to whatever is on the
¥ stack. Note: [] is used in JForth.
¥ We also allow [self] as a synonym of [ self ]
: ** 83 die ; ¥ "Has no meaning unless preceded by a selector"
: [] 83 die ;
: [SELF] 83 die ;
: SUPER> 83 die ;
: IVAR> 83 die ;
: CLASS_AS> 83 die ;
: ]
hide dfrSelID 1 = IF postpone ] EXIT THEN ¥ if no late bind, this is a
¥ standard Forth ]
dfrSelID NIF 187 die THEN ¥ late bound public ivar reference
¥ not implemented yet!
state
IF 251 ?pairs dfrSelID postpone literal
postpone send
ELSE $ deadbeef $ 106 db ¥ shouldn't happen
dfrSelID send
THEN
1 -> dfrSelID ; immediate
100 constant pubIvarTyp ¥ &&& temp
false value need_class?
false value implicit_late_bind? ¥ true for pre-2.7 auto-late-bind
¥ to locals or values
(* REFTOKEN ( -- cfa tokenType | -- various type )
is called when we've parsed a selector - it determines the type of the
following word.
The order of checking determines the priority of names. Up to 2.6 we
checked for locals first, but this was a bad idea since a local could
have the same name as an object, and implicit late binding to locals
was legal. This wouldn't show up until a crash at run time. So now we
check for temp objects, then ivars, then locals IF implcit_late_bind? is
true.
"various" will be the cfa of whatever came after the selector, or
( offset ^ivar ) for ivars and temp objects (which are treated as ivars
of the class Dummy).
*)
: REFTOKEN ¥ ( -- cfa tokenType | -- various type )
false -> need_class?
Mword ¥ grab next word
TOfind IF tmpObjTyp EXIT THEN ¥ check for temp object
IVfind IF ivarTyp EXIT THEN ¥ check for ivar
implicit_late_bind?
IF Pfind IF locTyp EXIT THEN ¥ check for named parm/locals
THEN
( here ) dup thread dup @ + (find) 0= ?error 125
dup ['] ** = IF lbTyp EXIT THEN
dup ['] [] = IF lbTyp EXIT THEN
dup ['] [ = IF bktTyp EXIT THEN
dup ['] [self] = IF lbSelfTyp EXIT THEN
dup ['] super> = IF superTyp EXIT THEN
dup ['] ivar> = IF pubIvarTyp EXIT THEN
dup ['] class_as> = IF true -> need_class? classTyp EXIT THEN
dup hdlr
CASE
$ BC0B OF >obj objTyp ENDOF
$ BC1D OF classTyp ENDOF
$ BC1F OF objPtrTyp ENDOF
$ BC03 OF valTyp ENDOF
¥ Note: here we can treat vectors as words.
126 die ¥ "Not an object name"
ENDCASE
¥ but if we got wordTyp or valTyp, it's only legal if implicit_late_bind?
¥ is true
implicit_late_bind? ?EXIT ¥ all OK - done
dup wordTyp = over valTyp = or
IF 126 die THEN
;
¥ These words handle the binding of a selector to whatever follows it.
(* FIX_PIVAR does the housekeeping for accessing a public ivar. When we
encounter msg: ivar> then we store the selector in pivSel, and the
hashed ivar name in pivar. We then continue with a zero "selector",
which signals that it's a public ivar access, and leads to us being
called back here to fix everything up once we've got the class.
*)
: FIX_PIVAR { ^class in_class? ¥ ^ivar offs xdispl-offs -- cfa offs xdispl-offs }
^class ?>classInMod -> ^class
pivar ^class <findIV> ¥ ( ^ivar offs xdispl-offs true OR false )
0= ?error 192 ¥ "ivar not found"
-> xdispl-offs -> offs -> ^ivar
^ivar iffa w@ ¥ get ivar flags
dup 4 and 0= ?error 193 ¥ ivar not public
2 and ¥ static flag
in_class?
IF 0= ?error 197 ¥ ivar not static
ELSE ?error 195 ¥ wrong syntax for public static ivar
THEN
¥ now we find the method in the ivar's class
pivSel ^ivar ivFindM drop ¥ %%% don't worry about large_obj_arrays
¥ which are ivars yet!
( cfa offs-within-ivar )
in_class?
IF ¥ for public static ivars, the "offset" we return is
¥ actually the ivar's real data address.
drop ^ivar static_ivar_offs + @abs -> offs
ELSE
++> offs
THEN
offs xdispl-offs
;
¥ PUBLIC_STATIC_IVAR_REF handles a message bind to a public static ivar
¥ (done via the msg: ivar> in_class someClass syntax)
: PUBLIC_STATIC_IVAR_REF
refToken
classTyp <> ?error 196 ¥ class name must follow in_class
true fix_pivar drop ¥ %%% don't worry about large_obj_arrays
¥ which are public static ivars yet!
0 bind_to_obj
;
¥ OBJREF handles a reference to a normal object.
: OBJREF { selID ^obj ¥ cfa offs xdispl-offs -- }
selID
IF selID ^obj objFindm
ELSE ¥ it's a public ivar reference in the referenced object
^obj >class false fix_pivar
THEN
( cfa offs xdispl-offs ) -> xdispl-offs -> offs -> cfa
xdispl-offs
IF
^obj xdispl-offs + lit_addr
" dup @ +" evaluate
offs IF ¥ will normally be zero
offs postpone literal
" +" evaluate
THEN
cfa bind_to_stk EXIT
THEN
cfa ^obj offs bind_to_obj
;
¥ IVARREF handles a reference to an ivar.
: IVARREF { selID ^ivar offs xdispl-offs ¥ cfa stat? -- }
heldMod 0 -> heldMod ¥ save
offs $ FFFE >= -> selfRef? ¥ if self or super. Allows private
¥ methods to be found by (findm)
selfRef?
IF supers_to_skip -> sups2skip ¥ sups2skip is interrogated by (findm).
¥ This must only be done if self or
¥ super is the target.
0 -> offs ¥ "real" offset is zero
ELSE
^ivar iffa w@ 2 and -> stat? ¥ static ivar?
THEN
selID
IF selID ^ivar ivFindM ¥ %%% don't worry about large_obj_arrays
¥ which are ivars yet!
selfRef? IF -> xdispl-offs ELSE drop THEN
++> offs ¥ add embedded obj base offs to ivar offs
-> cfa
0 -> sups2skip 0 -> supers_to_skip
selfRef?
IF xdispl-offs
IF xdispl-offs postpone literal
" ^base + dup @ +" evaluate
cfa bind_to_stk
ELSE
cfa offs bind_to_self false -> selfRef?
THEN
¥ ?unholdMod
-> heldMod EXIT
THEN
ELSE ¥ it's a public ivar reference within the referenced ivar
^ivar ^iclass false fix_pivar drop ¥ %%% don't worry about large_obj_arrays
¥ which are ivars yet!
++> offs -> cfa
THEN
stat?
IF cfa ^ivar static_ivar_offs + @abs 0 bind_to_obj
¥ ?unholdMod
-> heldMod EXIT
THEN
xdispl-offs
IF xdispl-offs postpone literal
" ^base + dup @ +" evaluate
offs IF ¥ will normally be zero
offs postpone literal " +" evaluate
THEN
cfa bind_to_stk
ELSE
cfa offs bind_to_ivar
THEN
¥ ?unholdMod
-> heldMod
;
¥ OP/CL is common code factored out of objPtrRef and classRef, which
¥ are very similar.
: OP/CL { selID ^class ¥ cfa offs xdispl-offs -- }
selID
IF selID ^class clFindm
ELSE
^class false fix_pivar
THEN
-> xdispl-offs -> offs -> cfa
xdispl-offs
IF xdispl-offs postpone literal
" + dup @ +" evaluate
THEN
heldMod ¥ save
offs postpone literal " +" evaluate
-> heldMod ¥ restore
cfa bind_to_stk
;
¥ OBJPTRREF handles a reference to an object pointer.
: OBJPTRREF { selID OP-cfa ¥ OPclass cfa offs xdispl-offs addr -- }
OP-cfa (comp) ¥ Compile a fetch of the OP-cfa,
¥ giving ^obj at run time
OP-cfa 2+ @abs -> addr
addr 4+ @abs -> OPclass
OPclass 0= ?error 86 ¥ "ObjPtr hasn't had a class specified"
OPclass hdlr -90 =
IF ¥ Class is exported
OPclass 6 + wdisplace ¥ Addr of module
compmod = ?error 84 ¥ It's the module we're compiling -
¥ this is a no-no, since the ObjPtr
¥ reference will use the OLD module!
OPclass ?>classInMod -> OPclass
THEN
selID OPclass OP/cl
;
¥ CLASSREF handles a reference to a class - this means use the object
¥ whose addr is on the stack, but ASSUME it is of the given class
¥ and early bind, without checking.
¥ The code is very similar to objPtrRef, naturally enough.
: CLASSREF { selID ^class ¥ cfa offs xdispl-offs -- }
need_class? IF ' chkClass -> ^class false -> need_class? THEN
selID ^class OP/cl
;
¥ TMPOBJREF handles a reference to a temp object. The temp obj
¥ is set up as an ivar of class Dummy.
: TMPOBJREF { selID ^ivar offs ¥ svHeldMod cfa xdispl-offs -- }
heldMod -> svHeldMod 0 -> heldMod
selID
IF selID ^ivar ivFindM
ELSE
^ivar 8 + @abs false fix_pivar
THEN
-> xdispl-offs ++> offs -> cfa
xdispl-offs
IF postpone locReg
xdispl-offs postpone literal postpone +
postpone dup postpone @ postpone +
offs IF offs postpone literal postpone + THEN ¥ will normally be zero
cfa bind_to_stk
ELSE
cfa offs bind_to_tmpObj
svHeldMod -> heldMod
THEN
;
¥ SuperRef handles the msg: super> someSuper construct.
: SUPERREF { selID ¥ ^nway namedClass ^nway' cnt -- }
?class ¥ Must be compiling a class
' -> namedClass ¥ get named class xt
^comp_class sfa -> ^nway
^nway -> ^nway' 0 -> cnt
BEGIN
^nway' @ 0= ?error 120 ¥ "superclass" not found
^nway' @abs namedClass =
NWHILE
1cell ++> ^nway' 1 ++> cnt
REPEAT
cnt -> supers_to_skip
selID
" SUPCL" sFind drop 46 + ¥ careful of hard-coded number here
$ FFFE 0 ivarRef ¥ equivalent to msg: super
;
forward COMPREF
¥ PubIvarRef handles the msg: ivar> someIvar IN someObj construct, to
¥ send a message directly to a public ivar in an object. At this point
¥ we've just read "ivar>".
: PUBIVARREF { selID ¥ addr len ^class ^ivar -- }
selID -> pivSel ¥ save selID being sent to the ivar
mword hash -> pivar ¥ parse ivar name
mword count -> len -> addr
addr len " IN" s=
IF 0 ¥ dummy "selID" for compRef (not a legal selector)
compRef ¥ handle whatever object comes after IN. The
¥ zero selector signals that a public ivar in the
¥ indicated object is to be accessed - real selectors
¥ can't ever be zero. This will lead to fix_pivar
¥ being called to complete the job.
ELSE
addr len " IN_CLASS" s=
IF public_static_ivar_ref
ELSE true ?error 194 ¥ "wrong syntax for public ivar"
THEN
THEN
;
¥ LBselfRef handles messages to [self] - i.e. late bound to Self.
: LBSELFREF ( selID -- )
" self" evaluate postpone literal ¥ pushes ^self, then selID
postpone send
;
¥ Now here are the main words which compile the selector bindings.
¥ CompRef operates at compile time - it compiles a selector bind.
:f COMPREF ¥ ( selID -- )
refToken ¥ ( selID <various> type )
¥ <various> will be the cfa of whatever came after the selector,
¥ or ( offset ^ivar ) for ivars and temp objects (which are
¥ treated as ivars of the class Dummy).
CASE
objTyp OF objRef ENDOF
ivarTyp OF ivarRef ENDOF
objPtrTyp OF objPtrRef ENDOF
tmpObjTyp OF tmpObjRef ENDOF
classTyp OF classRef ENDOF
¥ These next 3 can only come up if implicit_late_bind? is true:
¥ valTyp OF compdfr ENDOF
¥ locTyp OF compdfr ENDOF
¥ wordTyp OF compdfr ENDOF
lbTyp OF drop postpone literal
postpone send ENDOF
lbSelfTyp OF drop LBselfRef ENDOF
bktTyp OF drop -> dfrSelID 251 ENDOF
superTyp OF drop superRef ENDOF
pubIvarTyp OF drop pubIvarRef ENDOF
82 die ¥ "Selector can't be used on that"
ENDCASE ;f
(*
RunRef is the execution mode equivalent - it executes a selector bind.
We do this simply by compiling it in a buffer then executing it there.
The code is a bit like EX-GEN (see cg7).
While we're compiling in the buffer, we save CDP on the return stack,
then restore it before executing what we compiled (since it might do some
compiling itself). This isn't long, but it's a bit tricky:
*)
: runRefBuf ; ¥ never called, just ticked
256 code_reserve ¥ allows 4 nested binds - worst case
¥ 32 bytes each, we hope
0 value bufPtr
0 value hiCDP
: RUNREF { selID ¥ svCDP svBufPtr svState svMC svMD -- }
CDP -> svCDP ¥ save DP
CDP hiCDP umax -> hiCDP ¥ so we can reset CDP to right place on an error
bufPtr NIF ['] runRefBuf 2- ELSE bufPtr THEN
dup -> CDP -> svBufPtr ¥ now we'll compile in runRefBuf
state -> svState ¥ save state
¥ -1 -> state ¥ need compile state so this compilation works properly
:noname drop ¥ start a noname defn - drop security flag, leave xt
selID compRef ¥ compile the binding
300 postpone ; ¥ end noname defn, return to interpretation
svState -> state ¥ restore state
0 -> hiCDP ¥ don't need it any more and could cause problems
¥ ?unholdMod
CDP -> bufPtr ¥ new bufPtr value
¥ svBufPtr CDP svBufPtr - fix_caches
¥ we're about to execute what we just compiled
svCDP -> CDP ¥ restore CDP since the code might compile something
modCode -> svMC modData -> svMD
compmod
IF modcode_comp_start half_displ_range + -> modCode
moddata_comp_start half_displ_range + -> modData
THEN
( :noname xt ) execute ¥ execute compiled code
svMC -> modCode svMD -> modData ¥ restore module base addr regs
svBufPtr -> bufPtr ¥ and old bufPtr
;
¥ ======== Selector support =========
¥ MESSAGE is the handling word invoked by using a selector.
: MESSAGE immed
state
IF ¥ Compile state
compRef ¥ Compile the message send
¥ ?unHoldMod
ELSE
runRef ¥ Run state - execute object/vector reference.
¥ ?unHoldMod is called by ex-method at the
¥ end, so we don't need to call it here.
THEN ;
(*
FIND will call the forward-defined initFind first, to attempt to find
a name. So here we re-resolve initFind to lump together all the
special cases we have to look for after we've parsed an input word,
but before we can do a regular dictionary lookup.
At present these are selectors, named parms/locals, ivars
and local objects. If we invent more later, they can easily be added.
If we succeed here, we return the selector ID or zero, the cfa of the
handling word, and 1 or -1 (this will cause FIND to exit without doing
anything more). If we fail, we return the original string address and
false.
*)
:f initFIND ¥ ( str-addr -- selID message-cfa T | -- str-addr F )
sel? ¥ is it a selector?
IF hash ¥ yes - leave selID
['] message 1 ¥ and cfa of message, and 1 (it's immediate)
ELSE LocFind ¥ no - look for the various kinds of local name
THEN ;f
¥ ' 1stFind -> Ufind
: OBJLEN ¥ ( -- objlen ) Computes total data length of current object.
^base (^dlen) dup w@ swap 2+ w@ ?dup
IF idxBase 4- @ 1+ * + 4+ THEN ;
¥ SET_CLASS should only be used internally in the Mops implementation. It patches
¥ nucleus objects when their classes are defined in higher-level files. Actually
¥ it could be used to change the class of any object, but that wouldn't be a very
¥ clever thing to do.
¥ Usage: fFcb ['] file set_class
: SET_CLASS { ^obj theClass -- }
theClass chkClass ^obj 8 - reloc! ¥ Patch ^class
2 ^obj 2- w! ¥ Not indexed (yet)
-4 ^obj 4- w! ; ¥ ^class offset
: CHKSAME ¥ ( ^obj -- ^obj )
¥ A check that two objects are of exactly the
¥ same class.
dup >classXt ^base >classXt <> ?error 87 ;
¥ ========= Object pointers ==========
(* Object pointers are low-level objects (like VALUEs) which point to a
normal (high-level) object, and which allow early-bound messages to be
sent to the object by syntactically sending them to the object pointer.
The normal syntax is
ObjPtr ZZZ class_is someClass
Thereafter, any messages sent to zzz are early-bound to the object that
zzz points to at the time the message executes.
If you need to declare the object pointer before the class exists, use
SET_TO_CLASS once the class is defined, thus:
:class SOMECLASS super{ object }
' someOP set_to_class someClass
etc.
*)
: (toOP) { ^obj OPcfa ¥ OPclass -- }
^obj nilP = ¥ If we're storing nil, anything goes
check_OP_stores? not or ¥ Or if checking is turned off
NIF
OPcfa 4+ @abs -> OPclass
^obj 8 - @abs OPclass <>
IF ¥ Mismatch. We give some useful(?) info.
¥ cr ^obj obj> .id ." -> " OPcfa .id
87 die
THEN
THEN
^obj OPcfa ! ;
:f ToObjPtr
state
IF litAddr_h " (toOP)" evaluate ELSE (toOP) THEN ;f
: CLASS_IS ¥ ( --< class > )
?exec ' chkClass DP 4- reloc! ;
: SET_TO_CLASS { ^objPtr ¥ ^cl --< class > }
to_be_written
(*
' -> ^cl
^objPtr hdlr -62 <> ?error 85 ¥ "That isn't an ObjPtr"
¥ Now if "class" is an imported word, we change the handler code
¥ to "imported class". This is normally done when the module
¥ is compiled, but it may not be yet, since we probably
¥ want to refer to the ObjPtr in the module.
^cl hdlr -92 = IF -90 ^cl 2- w! ELSE ^cl chkClass drop THEN
^cl ^objPtr 4+ reloc!
*)
;
¥ ===================================
¥ Bytes is used as the allocation primitive for basic classes
: BYTES { numBytes ¥ svRec? -- }
?class
rec? -> svRec? true -> rec? ¥ Don't want an object header here
" object" sFind drop ivDef
numBytes ^comp_class dfa w+!
svRec? -> rec? ;
(* ================ Temp (local) objects ===================
Syntax:
: aWord { loc1 loc2 -- } ¥ Locals are optional, of course
temp
{ var v1
int i1
string s
}
Or you can use temp{ ... } if you prefer.
As the syntax is quite similar to a list of ivars of a class, we actually
implement the temp objects as though they're the ivars of a dummy class
(which we uncreatively call Dummy). This is just a convenience during
the compilation of a defn with temp objects. It allows us to define them
and keep them visible during the compilation of the definition, while mainly
using existing code for ivar access. We don't need these ivar dic entries
once the defn is finished, so we actually put them high in the dictionary
out of the way of the defn we're compiling. At the end of the defn,
we reinitialize Dummy's ivar link ready for next time.
*)
getSelect release: constant releaseID
:class DUMMY super{ object }
;class
' dummy ifa @ constant dummyIfa
¥ ivar link corresponding to no ivars - it will be a relative
¥ pointer to the n-way for the superclass, and thus a constant
: RESETTEMPS
dummyIfa ['] dummy ifa !
0 ['] dummy dfa ! ¥ clear dlen and xwid
;
¥ Note we don't have to worry about the mfa since Dummy never gets
¥ its own methods.
(* InitTemps is called when we're compiling the prologue for a definition
with temp objects. It compiles a call to make_obj for each object, so
that they're properly initialized. Note we can't just call make_obj once
using class Dummy, since its ivar list is wiped out after each defn
with temp objects, so at run time it won't have any! But we don't need
Dummy at run time anyway - we only need the "ivars" which are the
temp objects themselves.
*)
:f INITTEMPS { ¥ infa ^class -- }
['] dummy ifa displace -> infa
BEGIN
infa @ 0<
WHILE
infa ^iclass -> ^class
^class xwid
IF ¥ it's indexed - we'll have #elements on the stack,
¥ so we need to compile it as a literal for
¥ make_obj to grab at run time.
infa i#els postpone literal
THEN
^class lit_addr
infa ioffs postpone literal
postpone locreg postpone + postpone make_obj
infa ^nextivar -> infa
REPEAT ;f
(* ReleaseTemps is called from (;) in cg5 at the end of a definition.
It compiles a release: xxx for all temp objects. Because of the way
we've defined release: in class Object, for simple objects no code will
actually be generated.
Note we mustn't call resetTemps here since this might be an EXIT, not
the final semicolon. We leave calling resetTemps till a new temp{ comes
up.
*)
:f RELEASETEMPS { ¥ infa -- }
['] dummy ifa displace -> infa
BEGIN
infa @ 0<
WHILE
infa ^iclass 0EXIT ¥ shouldn't happen, actually
releaseID infa ivFindM 2drop
infa ioffs bind_to_tmpObj ¥ compile release:
infa ^nextivar -> infa
REPEAT
;f
: }TEMP
130 ?pairs
['] } >body ! ¥ restore old action for "}"
-> ^comp_class -> cstate
-> curr-def -> CDP ¥ restore other things
¥ Now we work out the temp obj framesize. We have to allow 8 bytes for
¥ the header, and an extra 8 in case it's not a method - in cg3 we add
¥ 16 to RP to get the temp obj pointer whether it's a method or not,
¥ so that we're always 8-byte aligned. This way we make sure we aren't
¥ going to run into what's underneath us on the rtn stack.
tempObjs dlen 16 + #align8 -> tempObj_framesize
local? NIF ¥ set up for entry unless we're in
PLentry initTemps ¥ a local section (then it gets done
THEN ¥ by :LOC)
['] releaseTemps -> releaseTemps_xt
¥ (;) compiles a call to there at semicolon time
postpone ] ¥ start compiling
;
: TEMP{ immed
(* First we have to allocate an internal local variable as a frame pointer.
There are 4 situations. There may or may not already be locals, and
we may or may not be in a local section. Note we can be in a local
section even if there aren't already locals, since the purpose of the
local section might be just to establish a section for these temp objects.
If there are already locals, we just add another. If we're not in a
local section we need to recompile the entry sequence (done by PLentry)
since the number of regs to be saved and set up is different. But if
we're in a local section, we don't have to recompile since we haven't
called PLentry yet, so we just add the extra local. If there aren't any
locals already, we just call initLocs which sets them up, before adding
the new one.
*)
resetTemps
#PL NIF initLocs THEN ¥ No locs before, so set up for them now
local? IF -1 -> local? THEN ¥ If in a local section, setting local?
¥ to -1 means we've defined the locals
¥ so can't do it again
true -> locFlg ¥ it's a local, not a parm
" x " pad place pad addToParmList ¥ pseudo local variable - name has
¥ a space so can't conflict
32 #PL - ¥ this is the GPR# for the frame pointer
dup -> TO_gpr# ¥ save it
<'> locReg 3+ c! ¥ and plug into locReg dic entry
(* Next we save CDP and move halfway up in the free dic space - we'll put
the "ivar dic entries" for the temp objs there - we don't need them
after the defn is compiled.
*)
CDP $ 2000 ++> CDP code_align
curr-def
cstate true -> cstate
^comp_class
['] } >body @ ¥ save old action for "}"
['] }temp -> } ¥ "}" will now be same as }temp
130 ¥ for ?pairs
['] dummy dup -> ^comp_class ¥ local objs will look like ivars of Dummy
-> tempObjs ¥ this will enable finding them
postpone [ ¥ stop compiling
;
: TEMP gobble{ postpone temp{ ; immediate
¥ set_CD_gpr# sets the GPR we're going to use for this definition to
¥ point to the start of the constant data. We make it an internal
¥ local variable, so the code is very similar to TEMP{ above.
variable tempv
:f set_CD_gpr#
CD_gpr# ?EXIT ¥ out if we've already done it
#PL NIF initLocs THEN ¥ No locs before, so set up for them now
local? IF -1 -> local? THEN ¥ If in a local section, setting local?
¥ to -1 means we've defined the locals
¥ so can't do it again
true -> locFlg ¥ it's a local, not a parm
" q " tempv place tempv addToParmList
¥ pseudo local variable - name has
¥ a space so can't conflict
32 #PL - ¥ this is the GPR# for the const data pointer
dup -> CD_gpr#
select: GPRs permanent: GPRs
;f
(*
¥ testing temp objects with indexing:
+echo
: q
temp{ 10 array aa
5 array bb
}
5 at: aa 4 to: bb
;
: qq db q ;
endload
*)
(* ================= Records and unions ====================
Syntax:
record <name> ¥ The name is optional
{ var v1
int i1
string s
}
union <name> ¥ The name is optional
{ var v1
int i1
string s
}
Or you can use record{ ... } or union{ ... } if you prefer, if it's
unnamed. The similarity of syntax to temp objects is quite deliberate.
But any similarity to Your Favorite Language is entirely accidental. Well
actually it's not, but I think this syntax is as good as any, and probably
more readable for folks coming from the land of C.
unions can be nested within records and vice versa.
NOTE: it's best to not use unions unless you're really sure you know what
you're doing. Having different objects sharing the same memory is sure
to cause problems if you're careless!
*)
: SVREC
^comp_class dfa w@
rec? union? unionOffs 68k_align?
;
: RSTREC
-> 68k_align? -> unionOffs -> union? -> rec?
union? IF ¥ we fell back in a union, so we
¥ reset data pointer to where it was at the beginning
¥ of this union/rec
^comp_class dfa w!
ELSE
drop
THEN
;
: ?HANDLE_NAME { ¥ sv_>in sv_^class sv_rec? -- }
>in @ -> sv_>in ^comp_class -> sv_^class rec? -> sv_rec?
Mword count " {" s=
NIF ¥ we've got a name for the record
true -> rec? ¥ must do this before defining the name "object"
sv_>in >in !
" object" sFind drop ivDef
sv_rec? -> rec? sv_^class -> ^comp_class
gobble{ ¥ "{" must follow
THEN
;
: }RECORD
131 ?pairs rstRec
['] } >body ! ;
: RECORD{
?class ¥ must be compiling a class
['] } >body @ ¥ save old action for "}"
['] }record -> } ¥ "}" will now be same as }record
svRec ¥ save parameters for any existing record/union
131 ¥ for ?pairs
true -> rec? false -> union? ;
: RECORD
?handle_name
record{ ;
: 68k_RECORD{
record{
true -> 68k_align? ;
: 68k_RECORD
record
true -> 68k_align? ;
: }UNION
132 ?pairs
unionOffs ^comp_class dfa w!
rstRec
['] } >body ! ; ¥ restore old action for "}"
: UNION{
?class ¥ must be compiling a class
['] } >body @ ¥ save old action for "}"
['] }union -> } ¥ "}" will now be same as }union
svRec ¥ save record/union parameters
132 ¥ for ?pairs
true -> rec? true -> union?
^comp_class dfa w@ -> unionOffs ;
: UNION
?handle_name
union{ ;
(* ================= Static ivars ====================
Syntax:
static
{ var v1
int i1
string s
}
Or you can use static{ ... } if you prefer.
These are like static class variables in C++ - they belong to the class,
not the object, and thus are shared by all objects of the class. We
allocate each ivar in the dictionary right after its ivar header.
*)
: }STATIC
133 ?pairs
['] } >body ! ¥ restore old action for "}"
false -> static? ;
: STATIC{
?class ¥ must be compiling a class
['] } >body @ ¥ save old action for "}"
['] }static -> } ¥ "}" will now be same as }static
133 ¥ for ?pairs
true -> static? ;
: STATIC
gobble{ static{ ;
¥ ==========================================
¥ CL1 is our first stage cleanup word - called on an abort. Resets things
¥ to normal. Later cleanup words do their special stuff, then call CL1.
¥ Actually on the PPC it's not quite the first, since we've loaded pFiles
¥ already, and so have already introduced clFiles as the file cleanup
¥ word. On the 68k it was really the first.
: CL1
(;cl) clrComp ['] (}) -> }
0 -> bufPtr 0 -> hiCDP ¥ for interpreting message binds
resetTemps
false -> rec? false -> union?
false -> 68k_align? false -> compinline?
0 -> extraFind
0 -> bufPtr
false -> case_in_names?
clFiles
;
' cl1 -> abortVec
torture? not [IF] endload [THEN]
(* ***********
¥ A simple test of the basic class stuff - run if the plot
¥ gets totally lost:
:class nothingClass super{ object }
;class
:class testClass super{ object }
:m aa: 1 2 3 ;m
:m bb: 99 aa: self ;m
;class
testClass ttt
bb: ttt ¥ should leave ( -- 1 2 3 99 )
:class cl2 super{ testClass }
testClass bloggs
:m cc: $ 1234
bb: bloggs
bb: super
;m
;class
cl2 myObj
cc: myObj
********** *)
¥ ===============================================================
¥ TORTURE TESTS
¥ ===============================================================
: ?CHK
2dup <>
IF cr .h cr .h
true abort" check FAILED!!!" ¥ error if something doesn't
¥ give what we expect
ELSE
2drop
THEN
;
:class VAR super{ object }
4 bytes data
:m CLEAR:
inline{ 0 ^base !} ;m
:m GET:
inline{ ^base @} ;m
:m PUT:
inline{ ^base !} ;m
:m GETT: ^base @ ;m
:m PUTT: ^base ! ;m
:m +:
inline{ ^base +!} ;m
:m -:
inline{ ^base -!} ;m
:m ->:
inline{ @ ^base !} ;m
:m TEST: @ ^base ! ;m
mlocal LOCTEST: { aa ¥ bb cc -- }
:m AAA: aa -> bb ;m
:mloc LOCTEST: ¥ should double the number passed in and store in self
aaa: self ¥ ." loctest: here!" cr
bb -> cc bb ++> cc
cc ^base !
;mloc
mlocal LOCTEST2: { aa bb cc dd ee ff ¥ gg hh ii -- }
:m bbb:
aa bb + cc * -> gg
dd ee + ff * -> hh
gg hh + -> ii
" hi there"
;m
:mloc loctest2:
bbb: self ii ^base !
" ho ho"
;mloc
:m PRINT:
^base @ . ;m
:m CLASSINIT:
$ 123 put: self ;m
;class
:class BYTE super{ object }
1 bytes data
:m CLEAR:
inline{ 0 ^base c!} ;m
:m GET:
inline{ ^base c@x} ;m
:m UGET:
inline{ ^base c@} ;m
:m PUT:
inline{ ^base c!} ;m
:m ->:
inline{ c@ ^base c!} ;m
:m PRINT:
^base c@ . ;m
:m CLASSINIT: 9 put: self ;m
;class
¥ some very simple testing, to start with:
0 value testVal
var aVar
byte aByte
: test1
." test1" cr
987 avar ! get: avar 987 ?chk ¥ optimizes
addr: avar -> testVal
876 testVal ! ¥ should clobber opt
get: avar 876 ?chk
;
: test2 ¥ testing late binding - assumes test1 done
." test2" cr
get: [ avar ] 876 ?chk
¥ now, does the late-bind cache work?
get: [ avar ] 876 ?chk
;
local localTest { ¥ aa bb cc dd -- }
: aaa " hahaha" ;
:loc localTest
aaa " hoho"
;loc
: test3 ¥ testing local methods, and local sections with const
¥ data. Note: we can assume ordinary local sections
¥ work, since we use them in the class stuff so we wouldn't
¥ have made it to here unless they work!!
." test3" cr
222 loctest: aVar get: aVar 444 ?chk
20 30 3 ¥ -> 150
10 30 4 ¥ -> 160
loctest2: aVar get: aVar 310 ?chk
" ho ho" s= -1 ?chk
" hi there" s= -1 ?chk
localtest " hoho" s= -1 ?chk
" hahaha" s= -1 ?chk
;
var vv
:class BOOL super{ byte }
:m GET:
inline{ ^base c@x} ;m
:m PUT:
inline{ 0<> ^base c!} ;m
:m SET:
inline{ true ^base c!} ;m
:m PRINT:
get: self IF ." true" ELSE ." false" THEN ;m
:m CLASSINIT: clear: self ;m
;class
:class BARRAY super{ object } 1 indexed
:m AT: ¥ ( index -- n )
inline{ ^elem c@} ;m
:m TO: ¥ ( n index -- )
inline{ ^elem c!} ;m
:m ^ELEM: ¥ ( index -- addr )
inline{ ^elem} ;m
:m FILL: ¥ ( value -- ) Fills all elements with value.
idxbase limit 2* bounds
?DO dup i c! LOOP drop ;m
:m WIDTH: 1 ;m ¥ Faster than the default in Object
:m GETELEM: ¥ ( addr -- n ) Fetches one element at addr
c@x ;m
:m TEST: at: self ;m
;class
¥ Testing arrays:
20 barray bb
: test4
." test4" cr
$ 9887 bb 20 + c!
12 -> testVal
testVal test: bb $ 87 ?chk
120 -> testVal
¥ ." should fail range check and trap - just step past the tw:" cr cr
¥ testval test: bb ¥ range check now omitted since Jasik doesn't
¥ like it. Try it after we've loaded our
¥ exception handler in zObjInit.
;
¥ also we test indexed classes which are subclassed and have
¥ added ivars, to make sure we get the right offset to the
¥ indexed header:
:class INDEXED-OBJ super{ object }
:m ^ELEM: ^elem ;m
:m LIMIT: limit ;m
:m WIDTH: idxbase 6 - w@ ;m
:m IXADDR: idxbase ;m
:m CLEARX: ¥ Erases indexed area.
idxbase limit width: self * erase ;m
:m CLASSINIT: clearX: self ;m
;class
:class WARRAY super{ indexed-obj } 2 indexed
:m AT: ¥ ( index -- n )
inline{ ^elem w@x} ;m
:m ATT: ^elem w@x ;m
:m TO: ¥ ( n index -- )
inline{ ^elem w!} ;m
;class
:class TRIGTABLE super{ wArray }
3 wArray AXISVALS
;class
10 trigtable ttt
$ 56 ttt $ 26 + w!
: test5 { ¥ xx -- }
." test5" cr
addr: ttt -> xx ¥ so we can look at it in the debugger
3 at: ttt $ 56 ?chk ;
¥ Testing object pointers
var vv1
objPtr ov class_is var
objPtr ov1 class_is var
objPtr ob class_is bool
: test6
." test6" cr
$ 765 put: vv $ 543 put: vv1
vv1 -> ov1 vv -> ov
gett: ov1 $ 543 ?chk get: ov $ 765 ?chk
$ 345 putt: ov get: ov $ 345 ?chk ;
¥ Testing static and public ivars
:class SIVTEST super{ var }
public
static
{ var V1
bool B1
byte B2
10 barray BB
}
bool BLOC
var VLOC
:m QQ: get: v1 get: b1 get: b2 4 at: bb
get: vloc ;m
:m TEST:
66 put: v1 77 put: vloc ;m
:m CLASSINIT:
32 put: v1 set: b1 33 put: b2 34 4 to: bb
set: bloc 34 put: vloc ;m
;class
sivtest zzz
sivtest sss
objPtr myop class_is sivtest
: QQQ
¥ classinit: zzz classinit: sss ¥ needed in qpClass, but not here
get: ivar> v1 in_class sivtest
test: sss
get: ivar> b2 in_class sivtest
get: ivar> v1 in_class sivtest
zzz get: ivar> bloc in class_as> sivtest
sss get: ivar> vloc in class_as> sivtest ;
: test7
." test7" cr
qqq
77 ?chk
-1 ?chk
66 ?chk
33 ?chk
32 ?chk
;
:class HAHA super{ object }
sivtest IVsss
:m QQ: test: IVsss get: ivar> vloc IN ivsss ;m
;class
haha hh
: test8
." test8" cr
classinit: zzz qq: hh 77 ?chk
get: ivar> vloc IN zzz
34 ?chk
;
¥ Testing late bind to self
:class VAR+ super{ var }
:m QQ: get: [self] ¥ should make class general
get: [ self ] ¥ shouldn't give any error
;m
;class
var+ VVV
¥ qq: vvv ¥ no need for ?chk since it will give its own error
: test9
." test9" cr
qq: vvv 2drop
;
¥ Testing records and unions. Also, the TEST: method piles up so many
¥ values that this also tests register spilling with a duplicate value!
:class RECTEST super{ object }
var vv
record RR
{ var v1
bool b1
3 barray bbb
byte b3 ¥ now aligned - unions should normally
¥ start out aligned, but we don't insist
¥ on it
union { byte b2
var v2
record { byte bb1
byte bb2 }
}
var v3
}
:m TEST:
4 0 to: bbb 5 1 to: bbb 6 2 to: bbb
$ 33 put: vv
$ 123 put: v1 set: b1
$ 124 put: v2 7 put: b3
$ 35 put: bb1 $ 36 put: bb2
$ 125 put: v3 $ 37 put: b2
get: v1 put: b1
get: b2 get: v2
get: bb1 get: bb2 get: v3
addr: rr 36 + @
;m
;class
recTest rrr
: test10
." test10" cr
$ 33 addr: vvv !
qq: vvv
$ 33 ?chk
$ 33 ?chk
test: rrr
$ 125 ?chk
$ 125 ?chk
$ 36 ?chk
$ 37 ?chk
$ 37360124 ?chk
$ 37 ?chk
rrr $ 2C + @ $ 04050607 ?chk
;
¥ testing multiple inheritance
:class INT super{ object }
2 bytes data
:m CLEAR:
inline{ 0 ^base ! } ;m
:m UGET:
inline{ ^base w@ } ;m
:m GET:
inline{ ^base w@x } ;m
:m PUT:
inline{ obj w! } ;m
:m PUTT: ^base w! ;m
:m IPUT: ^base w! ;m ¥ used in testing mult inheritance
:m CLASSINIT: $ 456 put: self ;m
;class
:class CC super{ byte int var bool }
:m TEST:
iput: self ¥ check it compiles
uget: self ¥ offs should be 0
+: self ¥ offs should be 4
set: self ;m ¥ offs should be E
:m TEST1:
set: self
get: super> bool ¥ should get -1
get: super
;m
:m setValues:
9 put: super> byte
$ 456 putt: super ¥ should go to the int
$ 456 put: super> int
$ 123 put: super> var
set: super
;m
;class
cc myCC
: test11 { ¥ addr -- }
." test11" cr
addr: mycc -> addr
setValues: mycc
mycc @ $ 09000000 ?chk
mycc 4+ @ $ fff40002 ?chk
mycc 8 + @ $ 04560000 ?chk
mycc 12 + @ $ ffec0002 ?chk
mycc 16 + @ $ 123 ?chk
mycc 20 + @ $ ffe40002 ?chk
mycc 24 + @ $ ff000000 ?chk
;
:class STRANGE super{ object }
var VV
byte BB
:m GET: get: vv get: bb ;m
:m PUT: put: bb put: vv ;m
;class
:class ARRAY super{ indexed-obj } 4 indexed
:m AT: ¥ ( index -- n )
inline{ ^elem @} ;m
:m ATT: ^elem @ ;m
:m TO: ¥ ( n index -- )
inline{ ^elem !} ;m
:m +TO: ¥ ( n index -- )
inline{ ^elem +!} ;m
:m -TO: ¥ ( n index -- )
inline{ ^elem -!} ;m
:m FILL: ¥ ( value -- ) Fills all elements with value.
idxbase limit 4* bounds
DO dup i ! 4 +LOOP drop ;m
:m ATEST:
1 at: self ;m
;class
:class MULT super{ var int array }
:m MTEST: $ 456 put: super> int $ 123 put: super> var
uget: super 999 1 to: self ;m
:m MAT: at: self ;m
;class
objPtr OO class_is mult
objPtr OOO class_is int
:class IVXX super{ object }
10 bytes data2
int i1
int i2
130 bytes qqqq ¥ Include to check >128 distance
¥ index addressing of array qwert
9 array qwert
:m ITEST:
$ 8456 dup i1 w! addr: i2 w! ¥ should be equivalent
get: i1 uget: i2 66 put: i2
99 3 to: qwert 1234 drop 3 at: qwert
addr: i2 -> ooo ;m
:m GETQWERT:
addr: qwert ;m
;class
int ii
3 mult mm
ivxx iv
: test12
." test12" cr
itest: iv
$ 63 ?chk
$ 8456 ?chk
$ ffff8456 ?chk
mtest: mm
$ 456 ?chk
88 iput: mm ¥ Note: get: mm will bind to the var, but uget: mm
¥ will bind to the int and give 88.
get: mm $ 123 ?chk
uget: mm 88 ?chk
;
: test13
." test13" cr
itest: iv
getqwert: iv 3 swap at: ** 99 ?chk
mtest: mm $ 456 ?chk
1 at: mm 999 ?chk
1 mat: mm 999 ?chk
1 mm at: mult 999 ?chk
1 mm at: [] 999 ?chk
mm -> oo
1 at: oo 999 ?chk
1 mat: oo 999 ?chk
uget: mm $ 456 ?chk
addr: mm addr: oo ?chk ¥ Both numbers shd be same
uget: ooo 66 ?chk
;
¥ testing ivSetup (via deep_classinit: ) - this should put the $123 and
¥ $456 in the var and the int, and store the same offsets in the header
¥ that are already there.
:class ivsTestClass super{ var int array }
record
{ var v1
int i1
byte b1
3 array a1
}
;class
5 ivsTestClass ivs1
: test14 { ¥ aa -- }
." test14" cr
deep_classinit: ivs1
addr: ivs1 @ $ 123 ?chk
addr: ivs1 4 + @ $ FFF4003A ?chk
addr: ivs1 8 + @ $ 04560000 ?chk
addr: ivs1 12 + @ $ FFEC0032 ?chk
addr: ivs1 16 + @ $ 123 ?chk
addr: ivs1 20 + @ $ 04560900 ?chk
addr: ivs1 24 + @ $ 0 ?chk ¥ array has no name so zero here
addr: ivs1 -> aa
addr: ivs1 28 + c@ $ 08 ?chk ¥ rest of reloc addr can change
addr: ivs1 32 + @ $ FFFC000A ?chk
addr: ivs1 36 + @ $ 4 ?chk
addr: ivs1 40 + @ $ 2 ?chk
;
¥ Testing temp objects
:class strxx super{ string }
:m RELEASE:
." string released" cr release: super
;m
;class
: leaf ;
: test15 { ¥ aa bb -- }
temp
{ var v1
var v2
strxx s1
}
." test15" cr
get: v1 get: v2
$ 123 ?chk
$ 123 ?chk
db
leaf
" hello world!" put: s1
." The next line should say hello world!" cr
get: s1 type cr
." The next line should say string released" cr
;
:class AAAA super{ object }
:m CLICK: { ¥ part ^ctl action1 action2 x y -- }
null
;m
;class
aaaa myAAAA
: test16
." test16" cr
click: myAAAA ;
¥ =========== TORTURE runs the test! ============
: TORTURE
." torture tests start..." cr cr
test1 test2 test3 test4 test5
test6 test7 test8 test9
test10 test11 test12 test13
test14 test15 test16
cr cr ." torture tests WORKED!!!" cr
;
+echo
: leaf ;
: BUG { ¥ neg? -- %x' }
fdrop
neg? if leaf then
;